COMMENT ⊗   VALID 00003 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	 A simple Combinator interpreter based on production rules.
C00008 00003	(progn 'compile
C00012 ENDMK
C⊗;
;;; A simple Combinator interpreter based on production rules.

(declare (special productions spaces *A *B *C) (*lexpr %umatch)
	 (*expr %instantiate)(fixnum spaces))

(eval-when (compile) (load "struct.fas[mac,lsp]"))


(defun n-spaces (n)
       (declare (fixnum n))
       (do ((n n (1- n)))
	   ((= n 0))
	   (tyo #o40)))

(defstruct production 
	  (antecedent ())
	  (consequent ())
	  (action ()))


(defun reduce (form)
       (let ((original form))
	    (terpri)(princ "Reducing: ")(princ form)
	    (print form)
	    (do ((form (process form)
		       (process form))
		 (old-form form form))
		((equal form old-form) 
		 (terpri)
		 (princ original) (princ " = ") (princ form)))))

(defun process (form)
       (cond ((%umatch '(*a (*b) *c)
		       form)
	      (let ((*A *A) 
		    (old-*B *B)
		    (spaces (1+ spaces))
		    (*C *C))
		   (terpri)(n-spaces spaces)
		   (princ spaces)(princ " ")
		   (princ "Processing: ")(princ *B)
		   (setq *B (process *B))
		   (terpri)
		   (n-spaces spaces)(princ spaces)(princ " ")
		   (princ old-*B)(princ " = ")(princ *B))
	      (setq form `(,@*A (,@*B) ,@*C))))
       (do ((productions productions (cdr productions)))
	   ((null productions) 
	    form)
	   (cond ((%umatch
		   (antecedent (car productions))
		   form)
		  (eval (action (car productions)))
		  (setq form (%instantiate (consequent (car productions))))
		  (terpri)(cond ((not (= spaces 0))
				 (n-spaces spaces)
				 (princ spaces)
				 (princ " ")))
		  (princ form)))))

(defun reducible (form1 form2)
       (let (hist1 hist2 intersect
		   (original-form1 form1)
		   (original-form2 form2))
	    (push form1 hist1)
	    (push form2 hist2)
	    (do ((form1 (apply1-reduction form1)
			(cond ((equal form1 old-form1) form1)
			      (t (apply1-reduction form1))))
		 (old-form1 form1 form1)
		 (old-form2 form2 form2)
		 (form2 (apply1-reduction form2)
			(cond ((equal form2 old-form2) form2)
			      (t (apply1-reduction form2)))))
		((or (equal form1 original-form2)
		     (equal form2 original-form1)
		     (setq intersect (intersection hist1 hist2)))
		 (cond ((equal form1 original-form2)
			(show-result (nreverse hist1)))
		       ((equal form2 original-form1)
			(show-result hist2))
		       (t (show-results hist1 hist2 intersect))))
		(cond ((equal form1 original-form1))
		      (t (push form1 hist1)))
		(cond ((equal form2 original-form2))
		      (t (push form2 hist2))))))

(defun apply1-reduction (form)
       (let ((nform form))
	    (cond ((%umatch '(*a (*b) *c)
			    form)
		   (let ((*A *A) 
			 (*C *C))
			(setq *b (apply1-reduction *B)))
		   (setq nform `(,@*A (,@*B) ,@*C))))
	    (cond ((not (equal nform form)) nform)
		  (t (do ((productions productions (cdr productions)))
			 ((null productions) 
			  nform)
			 (cond ((%umatch
				 (antecedent (car productions))
				 nform)
				(eval (action (car productions)))
				(return (%instantiate (consequent (car productions)))))))))))

(defun intersection (l1 l2)
       (do ((l1 l1 (cdr l1)))
	   ((null l1) ())
	   (cond ((member (car l1) l2)
		  (return (car l1))))))

(defun show-results (l1 l2 intersect)
       (do ((a (nreverse l1) (cdr a)))
	   ((equal (car a) intersect))
	   (print (car a)))
       (print '-)
       (do ((l2 l2 (cdr l2)))
	   ((equal (car l2) intersect)
	    (do ((l2 l2 (cdr l2)))
		((null l2) t)
		(print (car l2))))))

(defun show-result (l)
       (do ((l l (cdr l)))
	   ((null l) t)
	   (print (car l))))
(progn 'compile
       (setq productions () spaces 0)
       
       (push (make-production antecedent '(*h I ?x *t)
			      consequent '(*h ?x *r)) productions)
       
       (push (make-production antecedent '(*h C ?f ?x ?y *t)
			      consequent '(*h ?f ?y ?x *t)) productions)
       
       (push (make-production antecedent '(*h W ?f ?x *t)
			      consequent '(*h ?f ?x ?x *t)) productions)
       
       (push (make-production antecedent '(*h B ?f ?g ?x *t)
			      consequent '(*h ?f (?g ?x) *t)) productions)
       
       (push (make-production antecedent '(*h K ?x ?y *t)
			      consequent '(*h ?x *t)) productions)
       
       (push (make-production antecedent '(*h S ?f ?g ?x *t)
			      consequent '(*h ?f ?x (?g ?x) *t)) productions)
       
       (push (make-production antecedent '(*h PHI ?f ?a ?b ?x *t)
			      consequent '(*h ?f (?a ?x) (?b ?x) *t)) productions)
       
       (push (make-production antecedent '(*h PSI ?f ?g ?x ?y *t)
			      consequent '(*h ?f (?g ?x) (?g ?y) *t)) productions)
       
       (push (make-production antecedent '((*x) *t)
			      consequent '(*x *t)) productions)
       
       (push (make-production antecedent '(*b (Z 0) *t)
			      consequent '(*b (K I) *t)) productions)
       
       (push (make-production antecedent '(*b (Z ($r ?n (lambda (x)(or (not (numberp x))
								       (not (zerop x))))))
					      *t)
			      consequent '(*b (S B (Z ?n)) *t)
			      action '(cond ((numberp ?n)(setq ?n (1- ?n))) 
					    (t (setq ?n `(- ,?n 1))))) productions)
       
       (push (make-production antecedent '(*b (Z (+ ?n 1))
					      *t)
			      consequent '(*b (S B (Z ?n)) *t)) productions)
       
       (push (make-production antecedent '(*h D2 ?x ?y ?z *t)
			      consequent '(*h ?z (K ?y) ?x *t)) productions)
       
       (push (make-production antecedent '(*h Y ?f *t)
			      consequent '(*h W S (B W B) ?f *t)) productions)
       
       (push (make-production antecedent '(*h Y1 ?f *t)
			      consequent '(*h (W (B ?f))(W (B f)) *t)) productions)
       
       t)